MacWorld 1999 July

home *** CD-ROM | disk | FTP | other *** search

/ MacWorld 1999 July / Macworld (1999-07).dmg / Shareware World / Info / For Developers / Mops 3.4.sea / Mops source / PPC source / cg6 < prev next >

Wrap

Text File | 1999-01-14 | 53KB | 2,154 lines

PPC? [IF] false constant debug? [ELSE] false constant debug? [THEN] \ =============== SUNDRY INDIVIDUAL HANDLERS ================== OD valOD PPC? not [IF] : 68kReg>PPC { reg# \ regType -- ppc-reg# } reg# $ E0 and -> regType \ 0 Dn, $20 FPn, $40 An, $60 already a PPC reg reg# $ 1F and -> reg# regType CASE[ $ 60 ]=> reg# \ already a PPC reg# - leave unchanged [ 0 ]=> \ Dn on 68k reg# SELECT[ 1 ]=> 0 [ 3 ]=> I_reg DEFAULT=> drop 0 ]SELECT [ $ 20 ]=> [ $ 40 ]=> \ An on 68k reg# SELECT[ 2 ]=> obj_base_reg [ 3 ]=> mainData_reg [ 4 ]=> mainData_reg [ 5 ]=> modData_reg DEFAULT=> db drop 0 ]SELECT DEFAULT=> db ]CASE ; [THEN] : ^EXTRA_INFO { cfa -- addr } cfa c@ $ FF = IF 2 ELSE 4 THEN cfa + ; PPC? [IF] : genAddr { base-reg displ ind# -- } (* Rather similar to litaddr_h. Called via (OBJ) when we are compiling an inline method, and generating the object address. The "base-reg" may be negative, in which case the "displ" is an absolute address. I suspect ind# will always be zero on the PPC, so I'll trap it if it's not. *) ind# if $ deadbeef $ 129 db 2drop then base-reg 0< IF displ b&d ELSE base-reg displ THEN (litAddr) ; [ELSE] \ only change is to add 68kReg>PPC call. : genAddr { base-reg displ ind# -- } ind# if $ deadbeef $ 100 db 2drop then base-reg 0< IF displ b&d ELSE base-reg 68kReg>PPC displ THEN (litAddr) ; [THEN] : genXAddr { ixwid ixoffs base-reg displ local-displ ind# flags \ lim -- } (* Called by (IX) when we are compiling an in-line method, and generating the address of an indexed element of the current object. The base-reg, displ and ind refers to the obj addr. ixoffs is the offset to the indexed area, if we know it. This will happen if the obj is a straight object or an ivar (ivars are generic to a class, but each one has a fixed ixoffs). In these cases we can absorb the ixoffs at compile time. If, however, the "obj" is self or super, then we won't know the ixoffs at compile time, since at different points in the class hierarchy the ixoffs is different. It is always located at run time 2 bytes after the class pointer (this is changed from 68k). In this case we will pass in a negative "ixoffs". As for hGenaddr, the "base-reg" may be negative, which means that the "displ" is actually an absolute addr. *) -1 -> lim base-reg 0< IF displ ixoffs + 4- @ -> lim THEN ixoffs 0< IF " (^base) 2- dup w@x +" evaluate range_check? IF " 2dup 4- @ u> ?trap" evaluate THEN ELSE base-reg displ ixoffs + local-displ + ind# genAddr \ note - we can't just add the local-displ if ind# is nonzero, \ but I think on the PPC we can arrange for it to always be \ zero (and we'll get rid of it altogether eventually). \ run time: ( index ^indexed-area ) range_check? IF lim 0< IF " 2dup 4- @ u> ?trap" ELSE \ we have the object available " over" evaluate \ get index lim postpone literal " u> ?trap" THEN evaluate THEN THEN swap_cstk debug? if ." about to gen indexed addr - cstk:" printall: cstk then ixwid 1 > IF ixwid postpone literal postpone * THEN postpone + debug? if ." afterwards - cstk:" printall: cstk then ; : hStkObj \ ( -- base-reg displ ) (* Sets up for an early bind to an object whose (data) addr is on the stack at run time. We also handle object pointers this way, by first compiling a fetch of the objPtr to the stack, and relying on our optimization to improve the code. Rather than leaving the ^obj on the stack, we return the addressing info back to the CLASS code. This is because we may be binding to an inline method which uses OBJ anywhere - more than once, even. *) debug? if ." hStkObj called - cstk:" printall: cstk cr then 1 operands reftype: opnd1 gprRef <> IF 210 die THEN \ "can't bind to that" \ opnd1 get_to_reg? drop gpr: opnd1 [ ppc? not ] [if] $ 60 or \ the $60 marks this as a PPC reg, when target \ compiling only [then] 0 \ Note: we mustn't free: opnd1 here, since the upcoming early_bind \ call may execute inline code which allocates a reg! ; : CREATE_H litAddr_h ; : BUILDS_H 4+ litAddr_h ; : OBJ_H litAddr_h ; \ ptr points to obj's data, 12 bytes after \ the obj header ppc? not [IF] : CLASS_H db ; \ mustn't get called on the 68k - ppc_obj is what gets \ called. The proper PPC class_h is defined in qpClass. [THEN] : DO_FETCH { len flags \ reg# -- } 1 operands debug? if ." do_fetch - opnd1: " cr print: opnd1 then reftype: opnd1 gprNameRef = IF gprRef >refType: opnd1 opnd1 push EXIT THEN addr: opnd1 get_to_gpr? drop clear: theOD otFetch put: ivar> opType in theOD len put: ivar> len in theOD flags put: ivar> flags in theOD gpr: opnd1 dup -> reg# >Agpr: theOD 0 >Blit: theOD cascade&match? debug? if ." matched? " dup if ." yes" else ." no" then cr then NIF 1 results theOD copyWithoutCDP: GPRs compile: GPRs free: opnd1 THEN res1 push ; : DO_FP_FETCH { len \ reg# -- } 1 operands debug? if ." do_FP_fetch - opnd1: " cr print: opnd1 then reftype: opnd1 fprNameRef = IF fprRef >refType: opnd1 opnd1 fpush EXIT THEN addr: opnd1 get_to_gpr? drop clear: theOD otFPfetch put: ivar> opType in theOD len put: ivar> len in theOD gpr: opnd1 dup -> reg# >Agpr: theOD 0 >Blit: theOD cascade&match? debug? if ." matched? " dup if ." yes" else ." no" then cr then NIF 1 fresults theOD copyWithoutCDP: FPRs compile: FPRs free: opnd1 THEN res1 fpush ; (* RECORD_GPR_STORE puts an entry for the passed-in OD in stored_GPRs, in case we can optimize out a subsequent fetch of the same location (i.e. in the case where the stored value is still sitting in the reg we stored it from). We used to simply change the op in the stored GPR to a fetch, so it could match any subsequent fetch of that location. But it's better to keep a separate record in stored_GPRs, and check there for a match. This has the same effect, but means we don't have to clobber the prev info in the reg's OD - we might be able to match on the op that generated the value. Even if the GPR's type is otUnknown, although we won't be able to match on it, we still might be able to optimize out a subsequent fetch of the same location we're storing into. So we change the type to otUnkStored, which will mean we hang on to it a bit longer than otUnknown (which are up for grabs as soon as we need to allocate a free reg). We also clobber any fetch of the target location that might still be sitting around in a reg, since that value isn't valid any more. Special note: we don't record partial word stores, since in the general case, a fetch of that location WON'T be equal to the reg we stored from, and it's not worth trying to sort this out. *) OD storedOD objPtr whichRegs class_is ODs_class objPtr stored_regs class_is ODs_class : RECORD_REG_STORE { ^OD \ reg# -- } ^OD copyOD: storedOD debug? if ." recording store of " print: storedOD then reg: opnd2 -> reg# \ the reg we've stored reg# select: whichRegs CDP 4- mark_use: whichRegs get: ivar> len in storedOD 4 < IF debug? if ." no - len < 4 - not recording" then EXIT THEN reg# select: stored_regs ^OD copyOD: stored_regs get: ivar> opCDP in whichRegs put: ivar> lastRefCDP in stored_regs CDP 4- put: ivar> lastRefCDP in whichRegs get: ivar> opType in whichRegs otUnknown = IF otUnkStored put: ivar> opType in whichRegs THEN (* storedOD false match?: whichRegs IF otUnknown put: ivar> opType in whichRegs noType put: ivar> instrnType in whichRegs addr: ivar> myRef in whichRegs ->: tmpRef1 4 --> CDP tmpRef1 reg_changed 4 ++> CDP CDP 4- put: ivar> validTillCDP in whichRegs debug? if ." invalidated earlier fetch of same location:" print: whichRegs cr then THEN *) reg# select: whichRegs debug? if ." updated stored_regs:" cr printall: stored_regs cr then ; : RECORD_GPR_STORE GPRs -> whichRegs stored_GPRs -> stored_regs record_reg_store ; : RECORD_FPR_STORE FPRs -> whichRegs stored_FPRs -> stored_regs record_reg_store ; (* : RECORD_FPR_STORE { ^OD \ reg# -- } FPR: opnd2 select: stored_FPRs theOD copyWithCDP: stored_FPRs get: ivar> opCDP in FPRs put: ivar> lastRefCDP in stored_FPRs ; *) : COMPILE_THE_STORE { \ gpr# -- } Agpr: theOD -> gpr# refType: opnd2 CASE[ gprRef ]=> reg: opnd2 select: GPRs CDP put: ivar> lastRefCDP in GPRs [ fprRef ]=> reg: opnd2 select: FPRs CDP put: ivar> lastRefCDP in FPRs DEFAULT=> drop ]CASE gpr# 13 16 within? swap obj_base_reg = or refType: ivar> B_opnd in theOD litRef = and NIF debug? if ." it's a computed store" cr print: theOD cr ." current GPR " current: gprs . cr then free: opnd2 \ free the data reg - freeing it early is safe, \ and lets make_fetches_unknown mark the reg as \ "empty" so it can be reallocated make_fetches_unknown: GPRs make_fetches_unknown: FPRs invalidate_all: stored_GPRs invalidate_all: stored_FPRs compile: theOD CDP -> backstop_CDP ELSE theOD invalidate_on_overlap: GPRs theOD invalidate_on_overlap: FPRs theOD invalidate_on_overlap: stored_GPRs theOD invalidate_on_overlap: stored_FPRs compile: theOD free: opnd2 \ free the data reg (* Now we copy theOD to the corresponding stored_GPRs or stored_FPRs location, and set the lastRefCDP ivar. Note that this ivar has a special meaning for stores - it's the CDP for where the stored reg's value was generated. The normal meaning wouldn't make sense for stores anyway. *) refType: opnd2 CASE[ gprRef ]=> theOD record_GPR_store [ fprRef ]=> theOD record_FPR_store DEFAULT=> to_be_written drop ]CASE (* Finally we set the fetch backstop to straight after the store, so that we won't move any fetch forward past this point. To be able to do this, we'd need to do a full check for overlap possibilities, since any overlap would invalidate moving the fetch forward. This is doable, but rather complicated, since we may have already invalidated the record of an earlier store, so we'd need to keep a bytestring with info about all stores in the current definition. We could do this, but it's nasty, and probably not worth it just for this situation, which will probably hardly ever slow down a fetch anyway. *) CDP -> fetch_backstop THEN ; : DO_OP&STORE { len \ theOp -- } (* This handles an op into memory, such as ++> aValue. We fetch, operate, store. On entry, the top of cstk is a reference to a reg with the target addr. The second cell is a ref to the reg we're operating into that target. We start off with do_fetch which may cascade the address add. Whatever it does, it should leave the dest reg selected (where the data was fetched to). This will designate the actual fetch operation done, and we can use exactly this reg info to do the store later. We ensure that any antecedent regs aren't changed between the fetch and the store by bumping their refcnts for the duration. *) debug? if ." do_op&store called" cr then svOpcode -> theOp \ gets clobbered len 0 do_fetch \ do the fetch - dest GPR left selected gpr: cstk select: GPRs \ but in case it wasn't, we ensure it is. \ &&&& FPRs to_be_written !!! debug? if ." fetch done, to GPR: " cr print: GPRs then addr: GPRs copyOD: tmpOD \ save target OD, since we'll store \ using it shortly allocate: ivar> A_opnd in tmpOD \ Ensure any base regs needed for the allocate: ivar> B_opnd in tmpOD \ store, aren't clobbered by the op otStore put: ivar> opType in tmpOD \ at this point the cstk is ( stk-opnd mem-opnd ). We now need \ to (in effect) postpone a SWAP, since if the op is subtract, \ the stk-opnd must be subtracted from the mem-opnd. swap_cstk theOp -> operation do_arith_op \ do the operation 1 operands \ get the result reg (will normally be different) opnd1 ->: opnd2 \ compile_the_store expects it in opnd2 opnd1 ->: ivar> myRef in tmpOD \ but the store of that reg will be to the location \ we got before debug? if ." result reg:" gpr: opnd1 .g cr then tmpOD copyOD: theOD debug? if ." theOD before store:" print: theOD cr then compile_the_store debug? if dasm then free: ivar> A_opnd in tmpOD \ Because we did allocate: on them above free: ivar> B_opnd in tmpOD ; : (DO_STORE) \ factors out common code from DO_STORE and DO_FP_STORE. opnd2 >myRef: theOD \ the reg we're storing gpr: opnd1 >Agpr: theOD 0 >Blit: theOD debug? if ." (do_store) called, with a straight store" cr ." - initial store set up in theOD:" cr print: theOD cr dasm then cascade&match? drop \ stores never match anything, but a cascade \ might get done debug? if ." after cascade&match?" cr print: theOD cr ." opnd2 " print: opnd2 cr then \ opnd2 >myRef: theOD \ the reg we're storing debug? if ." theOD set up for store:" cr print: theOD cr then compile_the_store free: opnd1 \ free the dest addr reg - if we cascaded, this will \ have been deleted, but then opnd1 will have been \ changed to noRef and the free: will be ignored. ; : DO_STORE { len \ regForStore -- } debug? if ." do_store called with opcode " svOpcode .h cr printall: cstk dasm then \ svOpcode dup otStore <> swap otFPstore <> and svOpcode $ FF and otStore <> IF len do_op&store EXIT THEN \ cascade&match? wants the address operand in opnd1, so we'll get \ them in reverse order: swap_cstk 2 operands \ opnd2 = what we're storing, opnd1 = where refType: opnd2 SELECT[ gprRef ]=> \ nothing to do [ litRef ]=> opnd2 get_to_reg? drop [ crRef ]=> opnd2 0 cr>this_gpr 0 >gpr: opnd2 DEFAULT=> drop ]SELECT \ Now we have to check that the destination makes sense: refType: opnd1 SELECT[ gprRef ]=> \ nothing to do [ litRef ]=> opnd1 get_to_gpr? drop [ gprNameRef ]=> opnd2 get_to_gpr? drop gpr: opnd2 reg: opnd1 true moveReg: GPRs EXIT DEFAULT=> 214 die \ impossible store destination! ]SELECT \ now we set things up in theOD, since we might be able to cascade the addr. clear: theOD otStore put: ivar> opType in theOD len put: ivar> len in theOD (do_store) ; : DO_FP_STORE { len -- } debug? if ." do_FP_store called with opcode " svOpcode .h cr printall: cstk then \ cascade&match? wants the address operand in opnd1, so we'll \ organize things that way: 1 foperands opnd1 ->: opnd2 \ opnd2 = what we're storing 1 operands \ opnd1 = where ASSERT{ refType: opnd2 FPRref = } reftype: opnd1 SELECT[ gprRef ]=> \ normal store to mem - handled below [ fprNameRef ]=> fpr: opnd2 reg: opnd1 true moveReg: FPRs EXIT DEFAULT=> 214 die \ impossible store destination! ]SELECT \ now we set things up in theOD, since we might be able to cascade the addr. clear: theOD otFPStore put: ivar> opType in theOD len put: ivar> len in theOD (do_store) ; : SIZE>LEN \ converts our size codes to a length in bytes SELECT[ 0 ]=> 1 [ 1 ]=> 2 [ 2 ]=> 4 [ 3 ]=> 8 DEFAULT=> ]SELECT ; : @_H { cfa \ flags size -- } cfa ^extra_info -> cfa cfa 1+ c@ -> size cfa 3+ c@ -> flags size size>len flags do_fetch ; : !_H { cfa \ flags size -- } cfa ^extra_info -> cfa cfa c@ -> svOpcode cfa 1+ c@ -> size size size>len do_store ; : F@_H { cfa -- } 8 do_fp_fetch ; : SF@_H { cfa -- } 4 do_fp_fetch ; : F!_H { cfa -- } 8 do_fp_store ; : SF!_H { cfa -- } 4 do_fp_store ; PPC? not [IF] (* Here in 68k mode we define some interim versions of some of our floating point operations. This allows us do some testing on the FP code generation without having to load everything, and also lets us target compile code in Setup to initialize the FP regs. As interim ops, these are immediate and can only be used in a definition. *) : F@ 8 do_fp_fetch ; immediate : F! 8 do_fp_store ; immediate : SF@ 4 do_fp_fetch ; immediate : SF! 4 do_fp_store ; immediate : F+ otFADD -> operation dyadic_arith ; immediate : F- otFSub -> operation dyadic_arith ; immediate : F* otFMUL -> operation dyadic_arith ; immediate : FDROP tmpRef1 fpop free: tmpRef1 ; immediate : FDUP 1 foperands opnd1 fpush opnd1 fpush allocate: opnd1 ; immediate : FOVER 2 foperands opnd1 fpush opnd2 fpush opnd1 fpush allocate: opnd1 ; immediate [ELSE] (* In PPC mode we define (vop) which is the basic word which compiles a vector operation with 2 or 3 source operands and one destination. As we don't have a vector stack, the vector operands must be able to be determined at compile time - i.e. they must be on cstk. *) : (vop) { opcode vecKind 4op? \ gpr# vr# storeback? op1? lit? litVal -- } false -> storeback? false -> lit? true -> op1? 4op? IF 4 operands ELSE 3 operands opnd3 ->: opnd4 THEN \ opnd1 = source1, opnd2 = source2, opnd3 = source3 if any, opnd4 = dest. \ Any of these operands will be vrNameRef if it's a vector register object. reftype: opnd4 \ dest vrNameRef = IF \ dest is a VR reg: opnd4 \ dest dup -> vr# dup select: VRs >Bvr: VRs ELSE \ dest is in memory. We don't have a vector \ stack, so we do the operation in vr0, then \ store back. true -> storeback? opnd4 get_to_gpr? drop \ make sure we have base addr in a gpr 0 -> vr# 0 select: VRs otFetch otVecOffset + put: ivar> opType in VRs reg: opnd2 dup -> gpr# >Agpr: VRs 0 >Blit: VRs compile: VRs 0 >VR: opnd2 THEN \ now we need to do some special things if we have a literal operand: opcode CASE[ $ 80 ], [ $ 81 ]=> \ vector splat/splat immediate. \ For splat, opnd1 = source, opnd2 = literal indicating \ which element. \ For splat immediate, opnd2 = literal being splatted, \ opnd1 is a dummy, since we always have to have 3 operands. reftype: opnd2 litRef <> IF 228 postpone literal postpone die \ "splat: or Nsplat: must have a literal operand" EXIT THEN lit: opnd2 -> litVal opcode $ 81 = IF \ splat immediate -- we need to check the literal is \ within bounds. litVal -32 31 within? nip NIF 226 die THEN \ "Literal for Nsplat: must be between -32 and 31" vecKind $ 80 and NIF \ unsigned litVal 0< IF 227 die THEN \ "Nsplat: can't assign a negative literal to an unsigned vector" THEN false -> op1? \ no operand 1 in this case THEN true -> lit? DEFAULT=> drop ]CASE op1? IF reftype: opnd1 vrNameRef <> IF \ source is in mem. We fetch it to vr1. opnd1 get_to_gpr? drop 1 select: VRs otFetch otVecOffset + put: ivar> opType in VRs reg: opnd1 >Agpr: VRs 0 >Blit: VRs compile: VRs free: opnd1 1 >VR: opnd1 THEN ELSE 0 >vr: opnd1 \ no opnd1, so we just make sure the field is zero THEN 4op? IF \ we need to check if operand 3 is in mem, and \ if so, fetch to vr2. reftype: opnd3 vrNameRef <> IF \ it's in mem. opnd3 get_to_gpr? drop 2 select: VRs otFetch otVecOffset + put: ivar> opType in VRs reg: opnd3 >Agpr: VRs 0 >Blit: VRs compile: VRs free: opnd3 2 >VR: opnd3 THEN THEN lit? IF vr# select: VRs opcode otVecOffset + put: ivar> opType in VRs vecKind put: ivar> vecKind in VRs reg: opnd1 >Avr: VRs \ source register (zero if none) litVal >Blit: VRs \ literal value compile: VRs ELSE reftype: opnd2 vrNameRef <> IF opnd2 get_to_gpr? drop 2 select: VRs otFetch otVecOffset + put: ivar> opType in VRs reg: opnd1 >Agpr: VRs 0 >Blit: VRs compile: VRs free: opnd2 2 >VR: opnd2 THEN vr# select: VRs reg: opnd1 >Avr: VRs \ first source operand reg: opnd2 >Bvr: VRs \ second source operand 4op? IF reg: opnd3 >Cvr: VRs THEN \ third source operand, if any opcode $ 200 or put: ivar> opType in VRs opcode $ 23 $ 25 within? nip \ true if logical, for which vecKind is ignored. \ In some situations we mightn't have passed in zero, \ so in this case we just force it to zero. not vecKind and put: ivar> vecKind in VRs compile: VRs THEN storeback? IF gpr# >Agpr: VRs 0 >Blit: VRs otStore otVecOffset + put: ivar> opType in VRs compile: VRs gpr# free_gpr THEN ; \ we define __v2op and __v3op in file Vectors since they need intrp1 \ which isn't defined till cg7. [THEN] PPC? [IF] \ LITERAL is moved back to cg5 - we still need the old defn, and can't \ resort to ppc_immediate since in compiling numbers we need the new defn. [ELSE] : LITERAL \ ( n -- ) Compiles a fetch of n as a literal. \ We just push onto cstk, hoping we can combine with an \ op at run time clear: opnd1 >lit: opnd1 opnd1 push ; immediate [THEN] : fetchVal 64bit? IF 8 ELSE 4 THEN 0 do_fetch ; : storeVal 64bit? IF 8 ELSE 4 THEN do_store ; : VAL_H { ^value -- } debug? if ." val_h" cr then ^value 2+ -> ^value \ align on the reloc addr ^value @b&d \ get final base reg# and displacement (litAddr) \ generates the addr in GPR given by res1 & pushes \ gpr: res1 select: GPRs \ GPRs copyOD: valOD \ save the OD in valOD as we may need it svOpcode NIF \ it's a fetch fetchVal ELSE \ it's some kind of store storeVal THEN ; : FVAL_H { ^value -- } debug? if ." fval_h" cr then ^value 2+ -> ^value \ align on the reloc addr ^value @b&d \ get final base reg# and displacement (litAddr) \ generates the addr in GPR given by res1 & pushes svOpcode NIF \ it's a fetch 8 do_fp_fetch ELSE \ it's some kind of store 8 do_fp_store THEN ; : CONST_H \ ( cfa -- ) 2+ @ postpone literal ; \ not too hard! : FCON_H \ ( cfa -- } 2+ #align8 lit_addr postpone f@ ; : FETCHREG \ ( reg# code -- ) 3 = IF >gpr: opnd1 opnd1 push ELSE >fpr: opnd1 opnd1 fpush THEN allocate: opnd1 ; (* : FETCHREG \ ( reg# code -- ) 3 = IF localSect? NIF 1st_gpr_local 2+ 31 #P - within? \ 2+ because we don't want to include I and the \ do limit reg in the test! IF dup select: GPRs get: ivar> opType in GPRs NIF 112 die THEN THEN THEN >gpr: opnd1 opnd1 push ELSE localSect? NIF 1st_fpr_local 31 #FP - within? IF dup select: FPRs get: ivar> opType in FPRs NIF 112 die THEN THEN THEN >fpr: opnd1 opnd1 fpush THEN allocate: opnd1 ; *) : do_reg { reg# code -- } svOpcode NIF \ this is a fetch reg# code fetchReg ELSE \ this is some kind of store svOpcode otStore = NIF reg# code fetchReg svOpcode monadic? NIF swap_cstk THEN -> operation do_arith_op THEN code 3 = IF 1 operands opnd1 get_to_gpr? drop gpr: opnd1 reg# true moveReg: GPRs ELSE 1 foperands fpr: opnd1 reg# true moveReg: FPRs THEN THEN ; \ REG_H handles a reg reference - either GPR or FPR. It's never \ called for a 68k register. : REG_H { cfa \ mode reg# -- } cfa ^extra_info -> cfa cfa 1+ c@ \ reg# cfa c@ \ code - 3 = gpr, 4 = fpr do_reg ; : LOC_H \ note: loc# counts from right to left in the local/parm list, \ but we're assigning regs from left to right in the list, \ going from r31 down (since this simplifies EXECUTE). drop 32 #PL loc# - - 3 do_reg ; : FLOC_H \ does the same job for floating parms/locals. drop 32 #FPL loc# - - 4 do_reg ; : reg_name ( regcode reg# -- ) clear: opnd1 >reg: opnd1 regcode>nameRef >reftype: opnd1 opnd1 push ; : VECT_H { ^vect -- } ^vect 2+ -> ^vect \ align on the reloc addr ^vect @b&d \ get final base reg# and displacement (litAddr) \ generates the addr in GPR given by res1 & pushes svOpcode NIF \ it's an execute " doVect" evaluate \ late-bind using evaluate - doVect not defined yet true -> ctr_clobbered? \ the vect might do anything! ELSE \ it's a store to the vect " reloc!" evaluate THEN ; : SVECT_H { ^vect -- } \ system vectors are like vectors, but have a default \ value 4 bytes after the regular one, which gets used \ if the regular one is zero. ^vect 2+ -> ^vect \ align on the reloc addr pointing to data area ^vect @b&d \ get final base reg# and displacement (litAddr) \ generates the addr in GPR given by res1 & pushes svOpcode NIF \ it's an execute " doSvect" evaluate \ late-bind using evaluate - doSvec not defined yet \ the first time through true -> ctr_clobbered? \ the vect might do anything! ELSE \ it's a store to the vect " reloc!" evaluate THEN ; (* Dynamic vectors are "lightweight" vectors in which we don't use a relocatable addr but just store the xt to be executed, which allows us to point into a module if we know it's safe. These should never be saved in the dic and used after reloading - hence the name "dynamic". Like system vectors, zero means use the default, but the default is always do nothing. *) : dynVect_h { ^vect -- } ^vect 2+ -> ^vect \ align on the reloc addr pointing to data area ^vect @b&d \ get final base reg# and displacement (litAddr) \ generates the addr in GPR given by res1 & pushes svOpcode NIF \ it's an execute " @ execute" evaluate ELSE \ it's a store to the vect 4 do_store \ store passed-in xt THEN ; : PM_H \ ( cfa -- ) ^extra_info w@ -> operation do_arith_op ; : SHIFT_H \ ( cfa -- ) ^extra_info 1+ c@ -> subOperation \ 0 left, 1 logical right, 3 arith right otShift -> operation dyadic_arith ; : MULTDIV_H pm_h ; : CMP_H { cfa \ 68kCode compWithZero? unsigned? -- } cfa ^extra_info -> cfa cfa 1+ c@ -> 68kCode 68kCode $ 10 and -> compWithZero? 68kCode $ F and comparison_codes + c@ -> subOperation subOperation 2 and -> unsigned? compWithZero? IF 4 or> subOperation unsigned? monadic_comparison ELSE unsigned? dyadic_comparison THEN ; : FPCMP_H { cfa \ code compWithZero? -- } cfa ^extra_info -> cfa cfa 1+ c@ -> code code $ 4 and -> compWithZero? code -> subOperation compWithZero? IF FP_monadic_comparison ELSE FP_dyadic_comparison THEN ; : pushDesc_h { cfa \ hndlr -- } cfa ^extra_info -> cfa cfa c@ \ note the code is in the hi byte in case we ever need \ a subtype in the lo byte. CASE[ otDUP ]=> \ If we're DUPing a CR ref, we're surely not going \ to branch on it, but use it as an operand. We get \ much better code if we get it to a GPR straight \ away. postpone __>g 1 operands opnd1 push opnd1 push allocate: opnd1 [ ot2DUP ]=> 2 operands opnd1 push opnd2 push opnd1 push opnd2 push allocate: opnd1 allocate: opnd2 [ otDROP ]=> tmpRef1 pop free: tmpRef1 [ ot2DROP ]=> tmpRef1 pop free: tmpRef1 tmpRef1 pop free: tmpRef1 [ otSWAP ]=> swap_cstk [ otOVER ]=> 2 operands opnd1 push opnd2 push opnd1 push allocate: opnd1 [ $ 68 ]=> 2 operands \ NIP free: opnd1 opnd2 push [ $ 69 ]=> 2 operands \ TUCK opnd2 push opnd1 push opnd2 push [ $ 6A ]=> rot_cstk \ ROT [ $ 6B ]=> 3 operands \ DOWN opnd3 push opnd1 push opnd2 push [ $ 6C ]=> 4 operands \ 2SWAP opnd3 push opnd4 push opnd1 push opnd2 push [ $ 6D ]=> 3 operands \ 2PICK opnd1 push opnd2 push opnd3 push opnd1 push allocate: opnd1 [ $ 6E ]=> 4 operands \ 3PICK opnd1 push opnd2 push opnd3 push opnd4 push opnd1 push allocate: opnd1 [ $ 6F ]=> 4 operands \ 3ROLL opnd2 push opnd3 push opnd4 push opnd1 push [ $ 72 ]=> 1 foperands \ FDUP opnd1 fpush opnd1 fpush allocate: opnd1 [ $ 73 ]=> 2 foperands \ F2DUP opnd1 fpush opnd2 fpush opnd1 fpush opnd2 fpush allocate: opnd1 allocate: opnd2 [ $ 74 ]=> tmpRef1 fpop free: tmpRef1 \ FDROP [ $ 75 ]=> tmpRef1 fpop free: tmpRef1 \ F2DROP tmpRef1 fpop free: tmpRef1 [ $ 76 ]=> 2 foperands opnd2 fpush opnd1 fpush \ FSWAP [ $ 77 ]=> 2 foperands \ FOVER opnd1 fpush opnd2 fpush opnd1 fpush allocate: opnd1 [ $ 78 ]=> 2 foperands \ FNIP free: opnd1 opnd2 fpush [ $ 79 ]=> 2 foperands \ FTUCK opnd2 fpush opnd1 fpush opnd2 fpush [ $ 7A ]=> 3 foperands opnd2 fpush opnd3 fpush opnd1 fpush \ FROT [ $ 7B ]=> 3 foperands \ FDOWN opnd3 fpush opnd1 fpush opnd2 fpush [ $ 7C ]=> 4 foperands \ F2SWAP opnd3 fpush opnd4 fpush opnd1 fpush opnd2 fpush DEFAULT=> drop ]CASE ; : SWAP_H \ this is obsolete, but useful in testing before we've loaded \ the nuc. drop swap_cstk ; : CompJSRlong compile_call ; : INLINE_H { cfa -- } true -> compinline? cfa 1+ count evaluate false -> compinline? ; : INLINE{ { \ str-addr -- } drop \ drop stack flag (ppc_entry will replace) DP \ Save DP curr-def 2- -> DP \ back to flag bytes (will be replaced after \ the inline text) method? IF $ BD40 ELSE $ BD3C THEN \ replace handler code with appropriate DP 2- w! \ inline handler $ FF c, \ extra info mark, then the string (length in lo DP -> str-addr \ byte of extra info mark halfword). Note this & } ,str \ does "even" alignment at the end, but since \ it's starting from an odd byte, DP will be odd. \ We need to allow for the pad byte that might \ have been added, and allow for the 2 flag bytes. \ Thus, if the string length is even, the total \ len will be odd and there'll be a pad byte. In \ this case we add 1 to DP, otherwise 2. str-addr c@ 1 and 1+ ++> DP align \ Then 4-byte align DP -> CDP -> DP \ restore DP 0 -> state \ ppc_entry requires compilation off false ppc_entry \ recompile entry sequence method? IF drop 305 THEN \ methods have different security marker str-addr count evaluate \ compile out-of-line code \ note - this will be wound up properly when \ we hit the ; or ;m ; PPC? [IF] ppc_immediate [ELSE] immediate [THEN] \ ================ MOVE and ALIGNED_MOVE ================= (* I'm still deciding what's the best way to handle these. I think that for an aligned move of more than a couple of cells, it's OK to compile a branch-on-count loop, since branch prefetch will get rid of any branch latency, and there'll be no pipeline stall since the branch will only depend on the count register. For move_h, the moves could overlap, so for now I'll just do a call to the compiled definition for MOVE, which will just call BlockMoveData. Later I could check the operands and use alignedMove if I can detect at compile time that the move is aligned and non-overlapped. *) : Move_h call_h ; (* For alignedMove, we can assume the starting addresses are aligned, and there's no overlap. If the move is short enough, I'll just compile some inline load and store instructions. Otherwise I'll call the compiled defn for ALIGNED_MOVE, which will use a loop or a call to BlockMoveData. *) : AlignedMove_h { \ len cnt offs remainder -- } 1 operands refType: opnd1 litRef = IF lit: opnd1 -> len len 20 <= IF drop \ we'll generate inline instructions. We \ don't need the cfa of aligned_move len 2 >> -> cnt len 3 and -> remainder 0 -> offs cnt FOR postpone over offs postpone literal postpone + postpone @ postpone over offs postpone literal postpone + postpone ! 4 ++> offs NEXT remainder FOR postpone over offs postpone literal postpone + postpone c@ postpone over offs postpone literal postpone + postpone c! 1 ++> offs NEXT postpone 2drop EXIT THEN THEN opnd1 push call_h ; \ ================== MODULE SUPPORT ==================== PPC? [IF] (* Here's the format of an imported word: n bytes header 2 bytes handler code $BD2E 2 bytes export table offset for this word 4 bytes reloc addr of module object We come here to imported_h when a call to an imported word has to be compiled. We compile a push of the xt of the word, then a call to enterMod, which does the main work. We put enterMod in zModules, since it has to do a late-bound call to the module object, and this is much easier if it's not in the target compilation, and is also easier to debug. *) : IMPORTED_H ( xt -- ) lit_addr \ compile push of xt, for enterMod ['] enterMod call_h \ then compile call to enterMod \ which does the call to the module ; [THEN] \ ================== UTILITY PPC ROUTINES ==================== PPC? not [IF] : (REG) \ ( reg# code -- ) defining word defining a register. ppc_header $ BD0A codeW, \ handler code for reg_h $ FF02 codeW, \ extra info mark, 2 bytes extra info ( code ) codeC, ( reg# ) codeC, 0 codeW, \ align ; : GPR ( reg# -- ) 3 (reg) ; \ 3 = gpr -- we used it for D reg on 68k : FPR ( reg# -- ) 4 (reg) ; \ 4 = fpr [THEN] mainData_reg gpr MAINDATA modData_reg gpr MODDATA mainCode_reg gpr MAINCODE modCode_reg gpr MODCODE SP_reg gpr SP RP_reg gpr RP FSP_reg gpr FSP obj_base_reg gpr (^BASE) \ I_reg gpr I - moved to pnuc1 since we still need orig defn do_limit_reg gpr do_limit RTOC_reg gpr RTOC 1 gpr sys_SP 0 gpr GPR0 rX_reg gpr rX rY_reg gpr rY 31 gpr LOCREG \ for temp objects - gets patched to \ the appropriate reg# by temp{ 31 gpr ^constData \ points to constant data for curr \ defn - patched to approp reg# \ by set_constData_reg 14 fpr 0.0 \ we always have zero in fpr14 \ IMPORTANT NOTE: Since we sometimes save and restore FPRs onto the \ return stack, we always keep RP 8-byte aligned. So >R and R< \ use an 8 byte increment/decrement, not 4. We provide >Rx and \ R>x for internal use only, which don't 8-byte align, for setting \ up things like DO loops where we can be sure we'll end up 8-byte \ aligned anyway. : (>R) { 8align? -- } 1 operands opnd1 RP_reg 8align? if -8 else 1cell negate then true push_to_mem ( false -> leaf? ) ; (* The idea of the "false -> leaf?" was, that if we're in a leaf proc, the return addr isn't on the return stack, and this might break some code that tries to access the rtn addr with rtn stack operations. But this sort of monkeying with the rtn addr is highly nonstandard, and would never work anyway if there are locals, so we're not going to support it. *) : (R>) { 8align? -- } getFreeReg: GPRs >gpr: res1 RP_reg 0 8align? if 8 else 1cell then compPull: GPRs res1 push ( false -> leaf? ) ; \ >R, R> and R@ are in cg-cond. forward marker_h : NIMPL ." selector not implemented: " hex svSelector . ." opcode: " svOpcode . cr decimal 1 die ; ppc? [IF] : does_h { xt -- } xt 2+ @abs \ addr of data area of CREATEd word lit_addr \ compile a push of that addr for the runtime \ (does) code xt 6 + @abs \ xt of the runtime code call_h ; [ELSE] : does_h nimpl ; [THEN] : compPlLoop nimpl ; : hDoEx nimpl ; : hcompimp nimpl ; : bit_h nimpl ; : hLoadBA nimpl ; : FixDoes nimpl ; : hPatch nimpl ; \ : Floc_h nimpl ; \ : Fcon_h nimpl ; \ : Fval_h nimpl ; : FP1_h nimpl ; : FP2_h nimpl ; : hcompFPUL nimpl ; : FCRcon_h nimpl ; : hColA nimpl ; : hDefnEnd nimpl ; : colNoOpt_h nimpl ; : hComputedJMP nimpl ; : hEB nimpl ; ppc? not [if] : imported_h nimpl ; : class_in_mod_h nimpl ; [then] (* PPC_compile is the main word which gets called from the Mops system to compile PPC code. We do this by setting PPC? true, and setting the vector PPCvec to point to PPC_compile. This calls PPC_interpret if STATE is zero. On the PPC we need it to be a forward defn, hence what follows... *) PPC? not [IF] forward PPC_compile [THEN] \ ppc? [if] +echox [then] : PPC_interpret ( maybe xt here ) { handler opcode \ hndlr_code -- } handler $ FF00 and -> hndlr_code [ ppc? not ] [if] hndlr_code $ BE00 = IF ." can't execute a PPC colon defn on 68k!" 1 die THEN [then] \ hndlr_code $ BC00 <> \ IF ." can't execute this PPC word on 68k!" 1 die THEN handler $ FF and [ PPC? [IF] hexx [ELSE] hex [THEN] ] SELECT[ 1 ]=> \ maybe it's OK to execute a 68k word? Let's see... $ deadbeef $ 103 2drop execute [ 2 ]=> 2+ @ \ const_h [ 3 ]=> 2+ @abs @ \ val_h [ 4 ]=> 2+ @abs \ create_h [ 8 ]=> $ deadbeef $ 104 db ppc? drop 2drop ! \ store_h [ B ]=> 2+ @abs \ obj_h [ 1D ]=> ppc_obj \ class name - i.e. create \ an object of that class [ 38 ]=> \ hNoOpt is a no-op on PPC [ 3C ]=> inline_h \ inlines are sometimes \ OK in interpret mode [ 41 ]=> marker_h DEFAULT=> ." illegal selector for PPC_interpret: " .h cr ]SELECT [ PPC? [IF] decimalx [ELSE] decimal [THEN] ] ; :f PPC_compile ( maybe xt here ) { handler opcode \ hndlr_code -- } PPC? NIF ." whooops" 1 die THEN 0 -> operation 0 -> subOperation opcode -> svOpcode 0 -> svSelector handler $ FF00 and -> hndlr_code hndlr_code $ FF00 = IF \ it's a 68k-style handler code - convert to PPC equivalent handler negate 2/ -> handler THEN [ ppc? not ] [IF] state NIF handler opcode PPC_interpret EXIT THEN [THEN] hndlr_code $ BE00 = IF call_h EXIT THEN \ normal PPC call handler $ FFFF and $ BF01 = IF call_extern EXIT THEN \ external call (SYSCALL or EXTERN) handler $ FF and -> svSelector [ debug? ] [if] ." selector " svSelector .h ." opcode " svOpcode .h cr [then] [ PPC? [IF] hexx [ELSE] hex [THEN] ] svSelector SELECT[ 1 ]=> cr ." can't compile a call to a 68k word from PPC code!" 1 die [ 2 ]=> const_h [ 3 ]=> val_h [ 4 ]=> create_h [ 5 ]=> vect_h [ 6 ]=> pm_h [ 7 ]=> @_h [ 8 ]=> !_h [ 9 ]=> callStr_h [ A ]=> reg_h [ B ]=> obj_h [ C ]=> does_h [ D ]=> loc_h [ E ]=> litAddr_h [ F ]=> pushDesc_h [ 10 ]=> cmp_h [ 11 ]=> postpone literal \ "hLiteral" on 68k is same as literal [ 12 ]=> CompExit [ 13 ]=> CompJSRlong [ 14 ]=> pif [ 15 ]=> compPlLoop [ 16 ]=> \ hmentry does nothing - we handle at compile_prolog [ 17 ]=> [ ppc? ] [if] dbgr [else] PLentry [then] \ this handler code isn't used in PPC code - PLentry is \ called directly from { etc. [ 18 ]=> heb [ 19 ]=> \ hStkObj - never called from here? to_be_written [ 1A ]=> hDoEx [ 1B ]=> genaddr [ 1C ]=> genxaddr [ 1D ]=> class_h \ note - won't get called on 68k - ppc_obj \ is what gets called [ 1E ]=> hcompimp [ 1F ]=> val_h \ objPtr_h - fetches are identical to values [ 20 ]=> bit_h [ 21 ]=> swap_h [ 22 ]=> hLoadBA [ 23 ]=> FixDoes [ 24 ]=> hPatch [ 25 ]=> Floc_h [ 26 ]=> Fcon_h [ 27 ]=> Fval_h \ [ 28 ]=> FP1_h \ [ 29 ]=> FP2_h [ 2A ]=> FPcmp_h [ 2B ]=> hcompFPUL [ 2C ]=> FCRcon_h [ 2D ]=> class_h \ actually class_in_mod_h, but they're \ exactly the same! [ 2E ]=> imported_h [ 2F ]=> hColA [ 30 ]=> shift_h [ 31 ]=> hDefnEnd [ 32 ]=> F@_h [ 33 ]=> F!_h [ 34 ]=> builds_h [ 35 ]=> MultDiv_h [ 36 ]=> Move_h [ 37 ]=> AlignedMove_h [ 38 ]=> \ hNoOpt is a no-op on the PPC [ 39 ]=> colNoOpt_h [ 3A ]=> hComputedJMP [ 3B ]=> dynVect_h [ 3C ]=> inline_h \ won't be used for as on 68k [ 3D ]=> sVect_h \ won't be used for RBsysCall ditto \ these following ones aren't defined or used on the 68k: \ [ 3E ]=> >r_h \ [ 3F ]=> r>_h [ 40 ]=> inline_h \ inline methods [ 41 ]=> marker_h [ 42 ]=> SF@_h [ 43 ]=> SF!_h DEFAULT=> ." illegal selector: $" .h cr 1 die [ ppc? ] [if] dbgr [then] ]SELECT [ PPC? [IF] decimalx [ELSE] decimal [THEN] ] ;f (* ============================ ?trap is just for the code generator. It converts a preceding comparison to a trap instruction, for 1-instruction bounds checking. We trap if the comparison result was true. ============================ *) : ?TRAP { \ TO_bit# unsigned? -- } 1 operands [ debug? ] [if] ." ?trap - opnd1:" cr print: opnd1 [then] refType: opnd1 litRef = IF \ operands to comparison were known at compile time, so \ we can do the check straight away: lit: opnd1 0EXIT ." range check error found at compile time" 1 die THEN CR: opnd1 select: CRs \ we work out the TO-field bits to set, based on the condition in \ opnd1 and whether the comparison was signed or unsigned. The 3 \ leftmost bits are the same as CR field bits, but then there are \ 2 more bits for u< and u>. get: ivar> bit# in opnd1 -> TO_bit# get: ivar> opType in CRs otUCMP = -> unsigned? unsigned? IF 3 ++> TO_bit# THEN $ 10 TO_bit# >> unsigned? IF get: ivar> 1_is_true? in opnd1 NIF $ 07 xor THEN ELSE get: ivar> 1_is_true? in opnd1 NIF $ 1C xor THEN THEN put: ivar> subType in CRs otTrap put: ivar> opType in CRs recompile: CRs clear: CRs \ not a CR op any more ; PPC? [IF] ppc_immediate [ELSE] immediate [THEN] (* ============================ Here we define some ops as immediate macros using eval" - these were primitives in the 68k version, but our PPC code generator will produce optimum code from the macros - much better than calling out-of-line code. ============================ *) PPC? [IF] : ?DUP inline{ dup if dup then} ; : 0DUP inline{ dup nif dup then} ; [ELSE] : ?DUP eval" dup if dup then" ; immediate : 0DUP eval" dup nif dup then" ; immediate [THEN] (* ============================ Here we define any defining words we need to build special kinds of headers on the PPC. Generally these headers contain a handler code and extra info bytes which just give instructions to the code generator, and whose meaning is implied by the particular handler code. These bytes are headed by ah "extra info mark" - since this comes in the same position as the flag bytes on a normal colon defn, we'll use a value which is impossible for the flag bytes, just to prevent confusion. We'll use FFxx, where xx is the number of extra info bytes (excluding the mark). Then if normal out-of-line code follows (which can be called by EXECUTE), it will follow the extra info bytes. We'll pad to an odd-halfword boundary, then put the normal flag bytes, then the code. ============================ *) \ Use special_op thus: \ $ BD06 otAdd special_op + ; \ The handler code and the extra info code is pushed before special_op, then \ the name follows. : special_op { hndlr code \ cfa -- } ppc_header hndlr codeW, \ pm_h code CDP -> cfa $ FF02 codeW, \ extra info mark, 2 bytes extra info code codeW, \ the info 0 codeW, \ initial flag bytes for out-of-line code \ (we should now be aligned) false -> method? false ppc_entry \ compile entry for OUL code cfa hndlr code ppc_compile \ compile OUL code [ ppc? ] [if] curr-def 2- (;) 300 ?defn \ wind up OUL code - this is \ the same as "postpone ;" but \ we can't do that here! [else] postpone ; [then] ; PPC? not [IF] : dummy_op { hndlr -- } \ currently this is just used to define locParm and \ FlocParm, which don't do anything in themselves \ except have handler codes which cause locals to be \ accessed. ppc_header hndlr codeW, 0 codeW, \ align ; [THEN] : fetch_op { code flags \ cfa -- } ppc_header $ BD07 codeW, \ @_h code CDP -> cfa $ FF04 codeW, \ extra info mark, 4 bytes extra info code codeW, flags codeW, 0 codeW, \ padding to get to odd halfword 0 codeW, \ initial flag bytes for out-of-line code \ (we should now be aligned) false ppc_entry cfa $ BD07 code ppc_compile [ ppc? ] [if] curr-def 2- (;) 300 ?defn \ wind up OUL code [else] postpone ; [then] ; : simple_op { hndlr \ cfa -- } ppc_header hndlr codeW, \ handler code CDP -> cfa 0 codeW, \ initial flag bytes for out-of-line code \ (we should now be aligned) false -> method? false ppc_entry \ compile entry for OUL code cfa hndlr 0 ppc_compile \ compile OUL code [ ppc? ] [if] curr-def 2- (;) 300 ?defn \ wind up OUL code [else] postpone ; [then] ; PPC? [IF] endload [THEN] 0 value cg_CDP 0 value cg_DP 0 value norm_CDP 0 value norm_DP : CG_CODE_START CDP -> norm_CDP cg_CDP -> CDP cr ." code gen code start: $" CDP .h cr ; : CG_CODE_END cr cr ." code gen code end: $" CDP .h cr ." code gen code size: $" CDP cg_CDP - .h cr CDP nuc_code_start u> IF ." cg code overran its area!" QUIT THEN norm_CDP -> CDP ; : CG_DATA_START DP -> norm_DP cg_DP -> DP ." code gen data start: $" DP .h cr ; : CG_DATA_END cr cr ." code gen data end: $" DP .h cr ." code gen data size: $" DP cg_DP - .h cr DP nuc_data_start u> IF ." cg data overran its area!" QUIT THEN norm_DP -> DP ; : CROSS \ crosses the fence into PPC-land - starts PPC compilation. cr cr ." *************** PPC compilation started ***************" cr ['] PPC_compile -> PPCvec true -> PPC? \ PPC compilation on true -> crossed? \ Note: words such as CODE, which use a separate CDP, won't \ work as expected until PPC? is set true, since before then \ we keep it tied to DP so common code can be used. 0 -> #P 0 -> #PL align4 \ 4-byte align in data area DP -> data_start $ A000 reserve \ put code up the dictionary, clear data area \ now we set up the initial CDP, DP, code_start, code_limit, data_start \ and data_limit DP dup -> CDP dup -> data_limit dup -> code_start room + -> code_limit $ 48000000 code, \ put a branch at the start of the code, which \ will be resolved by INITIAL_ENTRY_POINT \ to our real initial entry point. info_block_size code_reserve \ and then reserve space for the info block \ which follows. This gets set up when we \ write the PEF 0 -> 1st_defn \ no defn yet data_start -> DP TOC_size allot \ initially allot TOC entries at start of data \ now for the target compilation, we want the code generator to come \ below the nucleus so we can omit it in installed apps. So we now \ allocate space for it in the code and data areas: CDP -> cg_CDP \ the start of the cg's code area DP -> cg_DP $ 22A00 code_reserve \ currently we need about 220xx $ 8000 reserve \ currently we need about 71xx \ now we're where we want the nuc to start CDP -> nuc_code_start DP -> nuc_data_start \ data_start -> nuc_data_start 4 ++> nuc_data_start ." code_start " code_start .h cr ." data_start " data_start .h cr ." nuc_code_start " nuc_code_start .h cr ." nuc_data_start " nuc_data_start .h cr ." mainCode " mainCode_val .h cr ." mainData " mainData_val .h cr cr CDP $ D000 erase \ clear code area which makes it easier to see what we generated gpr_call_cnt setup_cstk fpr_call_cnt setup_fcstk new: eq_ranges new: const_data new: sv_const_data ; : .STK printall: cstk ; : .STK2 printall: cstk2 ; : ENDPPC 0 -> PPCvec true -> 68k? PPC? 0EXIT \ out if windup already done false -> PPC? CDP -> code_limit DP -> data_limit CDP -> DP \ put DP back to normal place ; : INITIAL_ENTRY_POINT CDP -> init_entry ; immediate : .SIZE ." code size: " CDP 1st_defn - . cr ." data size: " DP data_start - . cr ; :f DASM 1st_defn CDP 2dup set_disasm_call_range disasm_rng cr ;f :f DCURR curr-def-code CDP set_disasm_call_range CDP dup 96 - swap disasm_rng cr ;f : ZZ endPPC release: const_data gpr_call_cnt setup_cstk ; :f Z \ endPPC .stk dasm cr .size ;f : ZB { #back -- } \ endPPC .stk code_start CDP set_disasm_call_range CDP dup #back - swap disasm_rng cr .size ; :f ZS $ 200 zb ;f : ZL $ 800 zb ; : DW disasm_word ; : DF \ "disassemble from" endPPC .stk ' >link CDP dup set_disasm_call_range disasm_rng cr .size ; : RL zz rl ; : FM zz fm ; : WP endPPC write_pef ; :ppc_code (DBGR) r12 8 r2 lwz, r12 0 r12 lwz, r12 mtctr, r11 r3 mr, r12 mflr, r12 -4 r17 stwu, bctrl, r12 r17 lwz, r17 r17 4 addi, r12 mtlr, r3 r11 mr, ;ppc_code : dbgr \ calls the debugger gracefully ['] (dbgr) cfa_adjust 2+ CDP 44 aligned_move 44 ++> CDP CDP -> backstop_CDP \ it's confusing if loads get hoisted here true -> ctr_clobbered? \ since it is! ; immediate : dbgrx \ calls the debugger ungracefully - but all regs \ are intact! 0 code, ; immediate (* Straight after the initial entry, we have to set up a legal frame on the system stack. We make it big enough that we can keep our Mops data stack entirely within this frame. Thus to the system, it appears that all our Mops machinations are a single procedure execution. The frame size is defined by sys_SP_framesixe in cg1. Now if we're a shared library, our initial entry will have to return to the caller, and nonvolatile regs will have to be saved and restored. So we save the ones we change here. We have to allow room for the parameter areas of the system calls we do during setup, so we just leave an arbitrary space of 200 bytes which should be plenty. *) :ppc_code (fixSP) r0 mflr, r0 8 rOSSP stw, r0 rOSSP mr, rOSSP sys_SP_framesize negate rOSSP stwu, RTOC 20 rOSSP stw, rMainCode 200 rOSSP stw, rMainData 204 rOSSP stw, rModCode 208 rOSSP stw, rModData 212 rOSSP stw, rRP 216 rOSSP stw, rSP 220 rOSSP stw, rFSP 224 rOSSP stw, r20 228 rOSSP stw, r21 232 rOSSP stw, r22 236 rOSSP stw, r23 240 rOSSP stw, r24 244 rOSSP stw, r25 248 rOSSP stw, r26 252 rOSSP stw, r27 256 rOSSP stw, r28 260 rOSSP stw, r29 264 rOSSP stw, r30 268 rOSSP stw, r31 272 rOSSP stw, rSP r0 mr, ;ppc_code : fix_sys_SP ['] (fixSP) cfa_adjust 2+ CDP 100 aligned_move 100 ++> CDP 0 >size: fcstk \ initially the FP stack isn't set up - this prevents \ any stores to it in the initial setup code ; immediate :ppc_code (initEnd) RTOC 20 rOSSP lwz, rMainCode 200 rOSSP lwz, rMainData 204 rOSSP lwz, rModCode 208 rOSSP lwz, rModData 212 rOSSP lwz, rRP 216 rOSSP lwz, rSP 220 rOSSP lwz, rFSP 224 rOSSP lwz, r20 228 rOSSP lwz, r21 232 rOSSP lwz, r22 236 rOSSP lwz, r23 240 rOSSP lwz, r24 244 rOSSP lwz, r25 248 rOSSP lwz, r26 252 rOSSP lwz, r27 256 rOSSP lwz, r28 260 rOSSP lwz, r29 264 rOSSP lwz, r30 268 rOSSP lwz, r31 272 rOSSP lwz, r3 0 li, \ return noErr rOSSP 0 rOSSP lwz, \ take down frame r0 8 rOSSP lwz, r0 mtlr, blr, ;ppc_code : init_end ['] (initEnd) cfa_adjust 2+ CDP 100 aligned_move 100 ++> CDP ; immediate (* : fix_sys_SP $ 7C320B78 code, \ mr SP, sys_SP $ 7C0802A6 code, \ mflr r0 $ 90010008 code, \ stw r0,8(sys_SP) sys_SP_framesize negate $ FFFF and $ 94210000 or code, \ stwu sys_SP, $-framesize(sys_SP) $ 90410014 code, \ stw RTOC,20(sys_SP) 0 >size: fcstk \ initially the FP stack isn't set up - this \ prevents any stores to it in the initial \ setup code ; immediate *) (* windup_SL_init takes down the above stack frame, when SETUP has been called as the init routine of a shared library. As we're returning to the caller, we must restore things properly. *) \ Some redefinitions, so we can still execute the 68k versions after CROSS: : +echox +echo ; : .errx .err ; : wordsx words ; : byex bye ; : hexx hex ; : decimalx decimal ; : cx, c, ; : allotx allot ; : reservex reserve ; : reloc!x reloc! ; : dumpx dump ; : endloadx endload ; : //x // ; : >namex 3- -1 traverse ; : displ!x displ! ; : relocCode,x relocCode, ; : CDPx CDP ; : DPx DP ; : .gsx .gs ; : zsx zs ; : 'x ' ; \ These are useful for bug-hunting without having to load the whole PPC image: : ROT rot_cstk ; immediate : DOWN 3 operands opnd3 push opnd1 push opnd2 push ; immediate string+ s file aFile : DFILE \ disassemble file clear: aFile -1 stdGet: aFile 0EXIT new: s open: aFile OK? aFile readAll: s close: aFile drop lock: s all: s over + 2dup swap 200 + swap set_disasm_call_range disasm_rng cr release: s 0 0 set_disasm_call_range ;